\ Shellsort Ham 12:00 11/01/92 \ This file contains a generic Shellsort (defined in 1959 by \ D. L. Shell). You need to write only two words: \ 1. A word that, given two item numbers, compares the \ appropriate parts of the items (the sort fields) and \ leaves a true flag if and only if the second item should \ be sorted BEFORE the first item. \ 2. A word that, given two item numbers, exchanges the \ contents of the two items. \ The addresses of these words are stored in PRIOR? and \ EXCHANGE respectively, and the number of elements in #ELTS. \ Executing SORT then performs the sort. SHUTTLE assumes signed\ numbers (uses 0<) and so limits sort to 32,767 or fewer items \ in a 16-bit Forth (2,147,483,647 or fewer in a 32-bit Forth). \ Sort vectors Ham 12:00 11/01/92 \ "i" denotes item number--e.g., slot number VARIABLE #ELTS \ the number of elements to be sorted VARIABLE PRIOR? \ address of word to do comparisons \ The stack diagram for the word in PRIOR? is ( i1 i2 - f ) \ The flag is true if contents of item2 ("i2") go BEFORE the \ contents of item1. That is, the word, given the indexes of \ two items, compares the sort fields of i1 and i2 and leaves \ a true flag if item 1 should be sorted before item 2. 2 4 THRU \ load the rest of the sort words \ Sort vectors Ham 12:00 11/01/92 VARIABLE EXCHANGE \ address of word to exchange items \ The stack diagram for the word in EXCHANGE is ( i1 i2 - ) \ This word will swap the contents of item1 and item2. In the \ example at the end of the screen file, it also displays the \ items (letters, in this example) in their new locations. : TESTSORT USING SORT 5 LOAD ; \ display message and \ conditionally load test case CR CR .( Enter TESTSORT for additional information. ) CR \ Shell sort setup Ham 12:00 11/01/92 : INTERVAL ( - gap ) 1 BEGIN 3 * 1+ DUP #ELTS @ 1- U> UNTIL ; ( gap = no. of elts apart for the partition ) : NEX ( gap i1 - nexti ) + ; \ leave no. of next item : BAK ( gap i1 - previousi ) SWAP - ; \ leave no. of prev item : SHUTTLE ( gap i - ) BEGIN 2DUP BAK ( 2 indexes now ) DUP 0< IF TRUE ( quit: have backed up past element no. zero ) ELSE SWAP 2DUP PRIOR? PERFORM ( do we need an exchange? ) IF 2DUP EXCHANGE PERFORM DROP FALSE ( keep going ) ELSE TRUE ( no = quit ) THEN THEN UNTIL 3DROP ; ( shuttle goes back up the partition until it doesn't need ) ( to make an exchange or until it exhausts the array bkwrds ) \ Shell sort Ham 12:00 11/01/92 : DOTHISPART ( gap 1st-i - gap ) BEGIN 2DUP NEX DUP #ELTS @ U< WHILE ( still within array: gap i1 i2 ) 2DUP PRIOR? PERFORM IF 2DUP EXCHANGE PERFORM >R ( save item # i2 ) 2DUP SHUTTLE ( using gap & i1 ) R> THEN NIP ( prev elt no.--the i1 we started with ) REPEAT ( through the partition ) 2DROP ; : DOEACHPART ( gap - gap ) DUP 0 DO I DOTHISPART LOOP ; : SORT INTERVAL BEGIN 3 / ?DUP ( down to next gap size ) WHILE ( gap size > 0 ) DOEACHPART REPEAT ( for next smaller gap size ) ; \ Example of conditional compilation Ham 12:00 11/01/92 CLS .( Enter GO for two Shellsorts. The first redisplays ) CR .( the entire screen for each exchange and as a result ) CR .( is slow--and also hard to read on an LCD screen; the ) CR .( second redisplays only the two exchanged characters. ) CR CR .( Enter n SORTS to see the faster sort n times. ) CR CR .( Example ) EXISTS? SORTS \ Have we already loaded the other screens? .IF .( ready.) \ If yes, just a message. .ELSE .( loading... ) 6 10 THRU \ If not, load them now. .THEN CR CR \ Random number generator Ham 12:00 11/01/92 \ Given an argument, returns a pseudo-random number between \ 0 and that argument. The pseudo-random sequence can be \ altered by changing the seed. -- Ray Duncan VARIABLE SEED : random ( -- n ) \ 0 <= n <= 32767 SEED @ 259 * 3 + 32767 AND DUP SEED ! ; : RANDOM ( n1 -- n2 ) \ 0 <= n2 < n1 random M* 32768 UM/MOD NIP ; \ Example Ham 12:00 11/01/92 \ This example will sort a screenful of characters into order \ according to their ASCII value 24 80 * EQU SIZE \ 24 lines of 80 characters each CREATE SORTPLACE SIZE ALLOT \ array big enough for 1920 chars : FILLUP SIZE 0 DO 126 32 - RANDOM 33 + I SORTPLACE + C! LOOP CLS SORTPLACE SIZE TYPE ; \ fill the array with random characters in the \ range of ASCII 33 (!) through ASCII 126 (~). : COMPARE ( i1 i2 - f ) SORTPLACE + C@ SWAP SORTPLACE + C@ < ; \ the comparison word: retrieve & compare \ the ASCII values of the two characters. \ Example Ham 12:00 11/01/92 : DISP ( i# - ) DUP SORTPLACE + C@ SWAP 80 /MOD GOTOXY EMIT ; \ retrieves char & displays it at the right spot on screen. : TYPEIT 0 0 GOTOXY SORTPLACE SIZE TYPE ; \ TYPE entire array VARIABLE EMIT? \ switch: EMIT chars, or TYPE entire array : SWAP'EM ( i1 i2 - ) 2DUP 2DUP \ 3 pairs on the stack now SORTPLACE + C@ ( char2 ) \ use stack to hold value SWAP SORTPLACE + C@ ( char1 ) ROT SORTPLACE + C! ( store at i2 ) SWAP SORTPLACE + C! ( store at i1 ) EMIT? @ IF DISP DISP ELSE 2DROP TYPEIT THEN ; \ Example Ham 12:00 11/01/92 : SETUP ['] COMPARE PRIOR? ! \ set up comparison ['] SWAP'EM EXCHANGE ! \ set up exchange SIZE #ELTS ! FILLUP ; \ set count and fill array : FAST EMIT? ON SETUP ; \ use EMIT to display only the two \ items exchanged : SLOW EMIT? OFF SETUP ; \ use TYPE to display entire array : MSG 440 15 BEEP 0 24 GOTOXY ." Press key to continue." KEY DROP ; \ GO and SORTS: Example ready to run Ham 12:00 11/01/92 : GO SLOW SORT MSG FAST SORT MSG ; : SORTS ( n - ) 0 ?DO FAST SORT LOOP ;
